The Arsenal Files 6/The Arsenal Files 6 (Arsenal Computer).ISO/prg_basi/ddfedit.zip/DDFFILE.FRM

Text File | 1996-02-05 | 14KB | 476 lines

VERSION 2.00
Begin Form FormFileDDF
   BackColor       =   &H00C0C0C0&
   Caption         =   "List of Files"
   ClientHeight    =   3825
   ClientLeft      =   2670
   ClientTop       =   3630
   ClientWidth     =   5925
   Height          =   4230
   Left            =   2610
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3825
   ScaleWidth      =   5925
   Top             =   3285
   Width           =   6045
   Begin SSPanel PanTop
      Align           =   1  'Align Top
      AutoSize        =   3  'AutoSize Child To Panel
      BevelOuter      =   0  'None
      BorderWidth     =   1
      Height          =   495
      Left            =   0
      TabIndex        =   3
      Top             =   0
      Width           =   5925
      Begin CommandButton FldCom
         Caption         =   "Cre&ate"
         Height          =   255
         Index           =   6
         Left            =   2880
         TabIndex        =   12
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Index"
         Height          =   255
         Index           =   5
         Left            =   2160
         TabIndex        =   11
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Close"
         Height          =   255
         Index           =   4
         Left            =   4545
         TabIndex        =   10
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Fields"
         Height          =   255
         Index           =   2
         Left            =   1440
         TabIndex        =   9
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&New"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   6
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Edit"
         Height          =   255
         Index           =   1
         Left            =   720
         TabIndex        =   5
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Delete"
         Height          =   255
         Index           =   3
         Left            =   3825
         TabIndex        =   4
         Top             =   0
         Width           =   735
      End
      Begin SSPanel PanHead
         AutoSize        =   3  'AutoSize Child To Panel
         BevelInner      =   1  'Inset
         BevelOuter      =   0  'None
         BorderWidth     =   1
         Height          =   255
         Left            =   0
         TabIndex        =   7
         Top             =   240
         Width           =   5475
         Begin TextBox TextTop
            BackColor       =   &H00C0C0C0&
            BorderStyle     =   0  'None
            Enabled         =   0   'False
            ForeColor       =   &H00FF0000&
            Height          =   195
            Left            =   30
            MultiLine       =   -1  'True
            TabIndex        =   8
            Text            =   "test test test"
            Top             =   30
            Width           =   5415
         End
      End
   End
   Begin TextBox XPath
      Height          =   285
      Left            =   120
      TabIndex        =   2
      Top             =   1200
      Visible         =   0   'False
      Width           =   180
   End
   Begin SSPanel PanList
      AutoSize        =   3  'AutoSize Child To Panel
      BevelInner      =   1  'Inset
      BevelOuter      =   0  'None
      BorderWidth     =   1
      Height          =   870
      Left            =   0
      TabIndex        =   0
      Top             =   240
      Width           =   3000
      Begin ListBox Llist
         Height          =   810
         Left            =   30
         TabIndex        =   1
         Top             =   30
         Width           =   2940
      End
   End
End
Option Explicit
Dim inited As Integer

Sub Field_edit ()
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDFile As XDFile_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim XDFileKey1 As XDFileKey0_def
  Dim FieldForm As New FormFieldDDF
  Dim i As Integer

  If llist.ListIndex = -1 Then Exit Sub
  ' look to see if a field form exists already for this file

  For i = 0 To Forms.Count - 1
    If Forms(i).Tag = "D" & Format(llist.ItemData(llist.ListIndex), "0") Then
      Forms(i).SetFocus
      If Forms(i).WindowState = 1 Then Forms(i).WindowState = 0
      Exit Sub
    End If
  Next i


  FileFullPath = XPath.Text & "FILE.DDF"

  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0


  stat = btrcall(B_OPEN, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If


  XDFileKey1.XFDid = llist.ItemData(llist.ListIndex)
  KeyBufLen = Len(XDFileKey1): BufLen = Len(XDFile)
  stat = btrcall(B_GETEQ, PosBlk, XDFile, BufLen, XDFileKey1, KeyBufLen, 0)

  If stat <> 0 Then
    MsgBox "Btrieve Error Retrieving Record in FILE.DDF " & Chr(10) & stat & " " & BtErr(stat)
  Else
    Load FieldForm
    FieldForm.XPath.Text = XPath.Text
    FieldForm.Tag = "D" & Format(XDFile.XFDid, "0")
    FieldForm.XFDid.Text = Format(XDFile.XFDid, "0")
    FieldForm.XFDName.Text = XDFile.XFDName
    FieldForm.XFDLocation.Text = XDFile.XFDLocation
    FieldForm.XFDFlags.Text = Format(Asc(XDFile.XFDFlags), "0")

  End If

  stat = btrcall(B_CLOSE, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)

End Sub

Sub File_Create ()
  Dim FileID As Integer
  Dim Location As String
  Dim p1 As Integer, p2 As Integer
  Dim ll As String


  If llist.ListIndex = -1 Then Exit Sub

  FileID = llist.ItemData(llist.ListIndex)

  If FileID < 4 Then
    MsgBox "You CANNOT recreate Dictionary Files !", , "Hmmmm.."
    Exit Sub
  End If

  If MsgBox("Recreating File will completely Erase all data in previous version" & Chr(10) & "Are you Sure you wish to proceed ?", 4 + 16, "WARNING") <> 6 Then Exit Sub

  ' extract the file's location from the list box !
  ll = llist.List(llist.ListIndex)

  ' skip the first tab
  p1 = 1: p2 = InStr(p1, ll, Chr(9))

  p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
  Location = Trim(Mid(ll, p1, p2 - p1))

  Create_btrfile (XPath.Text), Location, FileID

End Sub

Sub File_Delete ()
  Dim idx As Integer, xfid As Integer
  idx = llist.ListIndex
  If idx < 0 Then Exit Sub
  If idx < 3 Then
    MsgBox "You CANNOT delete the system Files !", , "ERROR"
    Exit Sub
  End If


  If MsgBox("Are you SURE you wish to Delete Selected file" & Chr(10) & "And all relevant Fields ?", 16 + 4, "Delete File") = 6 Then
    File_Remove (XPath.Text), (llist.ItemData(llist.ListIndex))
    listfill
  End If


End Sub

Sub File_edit ()
  Dim p1 As Integer, p2 As Integer
  Dim ll As String
  Dim idx As Integer
  idx = llist.ListIndex

  If idx = -1 Then Exit Sub
  If idx < 3 Then
    MsgBox "You CANNOT edit the system Files !", , "ERROR"
    Exit Sub
  End If

  ll = llist.List(idx)
  Load FormNewFile
  p1 = 1: p2 = InStr(p1, ll, Chr(9))
  FormNewFile.NewFileName.Text = Trim(Mid(ll, p1, p2 - p1))

  p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
  FormNewFile.NewFileLocation.Text = Trim(Mid(ll, p1, p2 - p1))

  FormNewFile.Caption = "Edit File"
  FormNewFile.XPath.Text = XPath.Text
  FormNewFile.NewFileIDX.Text = Format(llist.ItemData(idx), "0")
  FormNewFile.Show 1
  listfill

End Sub

Sub File_New ()
  Dim last As Integer
  Load FormNewFile
  FormNewFile.Caption = "Add New File"
  FormNewFile.XPath.Text = XPath.Text
  FormNewFile.NewFileIDX.Text = "-1"
  FormNewFile.Show 1
  last = llist.ListCount
  listfill
  If llist.ListCount <> last Then
    llist.ListIndex = llist.ListCount - 1
    Field_edit
  End If
End Sub

Sub FldCom_Click (index As Integer)
  Select Case index
    Case 0: File_New ' new
    Case 1: File_edit ' edit
    Case 2: Field_edit
    Case 3: File_Delete ' delete
    Case 4: Unload Me
    Case 5: Index_edit
    Case 6: File_Create
  End Select

End Sub

Sub Form_Activate ()
  If inited Then Exit Sub
  Me.Caption = "Files in " & XPath
  listfill
End Sub

Sub Form_Load ()
  inited = False
End Sub

Sub Form_Resize ()
  If WindowState = 1 Then Exit Sub
  PanHead.Left = 0
  PanHead.Width = PanTop.Width
  PanList.Left = 0
  PanList.Width = ScaleWidth
  PanList.Top = PanTop.Height
  PanList.Height = ScaleHeight - PanList.Top
End Sub

Sub Form_Unload (Cancel As Integer)
  Dim Found As Integer, i As Integer
  Dim MyPath As String
  MyPath = Trim(XPath.Text)
  Debug.Print "****  CLOSING CHILD FORMS "; MyPath
  Do
    Found = False
    For i = 1 To Forms.Count - 1 ' skip main form !
      Debug.Print Trim(Forms(i).XPath.Text), Trim(MyPath)
      If Trim(Forms(i).XPath.Text) = Trim(MyPath) Then
        If Forms(i).Caption <> Me.Caption Then
          Debug.Print "FOUND " & Forms(i).Caption
          Found = True
          Unload Forms(i)
          Exit For
        End If
      End If
    Next i
    If Found = False Then Exit Do
  Loop

End Sub

Sub Index_edit ()
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDFile As XDFile_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim XDFileKey1 As XDFileKey0_def
  Dim IndexForm As New FormIndexDDF
  Dim i As Integer

  If llist.ListIndex = -1 Then Exit Sub
  ' look to see if a field form exists already for this file

  For i = 0 To Forms.Count - 1
    If Forms(i).Tag = "D" & Format(llist.ItemData(llist.ListIndex), "0") Then
      Forms(i).SetFocus
      If Forms(i).WindowState = 1 Then Forms(i).WindowState = 0
      Exit Sub
    End If
  Next i


  FileFullPath = XPath.Text & "FILE.DDF"

  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0


  stat = btrcall(B_OPEN, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If


  XDFileKey1.XFDid = llist.ItemData(llist.ListIndex)
  KeyBufLen = Len(XDFileKey1): BufLen = Len(XDFile)
  stat = btrcall(B_GETEQ, PosBlk, XDFile, BufLen, XDFileKey1, KeyBufLen, 0)

  If stat <> 0 Then
    MsgBox "Btrieve Error Retrieving Record in FILE.DDF " & Chr(10) & stat & " " & BtErr(stat)
  Else
    Load IndexForm
    IndexForm.XPath.Text = XPath.Text
    IndexForm.Tag = "D" & Format(XDFile.XFDid, "0")
    IndexForm.XFDid.Text = Format(XDFile.XFDid, "0")
    IndexForm.XFDName.Text = XDFile.XFDName
    IndexForm.XFDLocation.Text = XDFile.XFDLocation
    IndexForm.XFDFlags.Text = Format(Asc(XDFile.XFDFlags), "0")

  End If

  stat = btrcall(B_CLOSE, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)

End Sub

Sub listfill ()

  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDFile As XDFile_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim X As Integer
  Dim WhosFile As String

  llist.Clear

  KeyBufLen = Len(Keybuf)
  BufLen = Len(XDFile)

  ' first open the file
  FileFullPath = XPath.Text & "FILE.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  stat = btrcall(B_OPEN, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If


  KeyBufLen = Len(Keybuf): BufLen = Len(XDFile)
  stat = btrcall(B_GETLW, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)

'  Texttop.Text = "Id" & Chr(9) & "Name" & Chr(9) & "Location" & Chr(9) & "Owner" & Chr(9) & "Reserved"
  Texttop.Text = "Name" & Chr(9) & "Location" & Chr(9) & "Owner" & Chr(9) & "Reserved"
  Do
    If stat <> 0 Then Exit Do

    If Asc(XDFile.XFDFlags) = 16 Then
      WhosFile = "*SYS"
    Else
      WhosFile = "User"
    End If
    'llist.AddItem XDFile.XFDid & Chr(9) & Trim(XDFile.XFDName) & Chr(9) & Trim(XDFile.XFDLocation) & Chr(9) & WhosFile & Chr(9) & Trim(XDFile.XFDReserved)
    llist.AddItem Trim(XDFile.XFDName) & Chr(9) & Trim(XDFile.XFDLocation) & Chr(9) & WhosFile & Chr(9) & Trim(XDFile.XFDReserved)
    llist.ItemData(llist.NewIndex) = XDFile.XFDid

    KeyBufLen = Len(Keybuf): BufLen = Len(XDFile)
    stat = btrcall(B_GETNX, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)
  Loop

  If stat <> 9 Then MsgBox "Btrieve Error Retrieving Record in FILE file " & Chr(10) & stat & " " & BtErr(stat)


  stat = btrcall(B_CLOSE, PosBlk, XDFile, BufLen, Keybuf, KeyBufLen, 0)

  X = AutoSetTabStopsCheck(llist, Texttop, False, False)
  inited = True
End Sub

Sub Llist_DblClick ()
  Field_edit

End Sub